3. Train & Test Veri Kümeleri
library(caret)
## Zorunlu paket yükleniyor: ggplot2
## Zorunlu paket yükleniyor: lattice
set.seed(74367432)
train_id<-createDataPartition(data$DEATH_EVENT, p=0.80, list=FALSE, times=1)
caret paketindeki createDataPartition fonnksiyonunu kullanarak, data veri setimizin train ve test veri kümelerine hangi yüzdeliklerle ayrılacağını belirlemek için train_id adlı değişkeni oluşturduk.
train<-data[train_id,]
test<-data[-train_id,]
train_id değişkeninden yararlanarak train ve test veri kümelerimizi oluşturduk.
library("openxlsx")
write.xlsx(train, 'train.xlsx')
write.xlsx(test, 'test.xlsx')
openxlsx paketindeki write.xlsx fonksiyonundan yararlanarak, train ve test veri kümelerimizi yazdırdık.
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
glimpse(train)
## Rows: 240
## Columns: 13
## $ age <dbl> 50, 65, 90, 60, 65, 80, 62, 45, 50, 49, 82, 8~
## $ anaemia <fct> Yes, Yes, Yes, Yes, No, Yes, No, Yes, Yes, Ye~
## $ creatinine_phosphokinase <dbl> 111, 160, 47, 315, 157, 123, 231, 981, 168, 8~
## $ diabetes <fct> No, Yes, No, Yes, No, No, No, No, No, No, No,~
## $ ejection_fraction <dbl> 20, 20, 40, 60, 65, 35, 25, 30, 38, 30, 50, 3~
## $ high_blood_pressure <fct> No, No, Yes, No, No, Yes, Yes, No, Yes, Yes, ~
## $ platelets <dbl> 210000, 327000, 204000, 454000, 263358, 38800~
## $ serum_creatinine <dbl> 1.90, 2.70, 2.10, 1.10, 1.50, 9.40, 0.90, 1.1~
## $ serum_sodium <dbl> 137, 116, 132, 131, 138, 133, 140, 137, 137, ~
## $ sex <fct> Male, Female, Male, Male, Female, Male, Male,~
## $ smoking <fct> No, No, Yes, Yes, No, Yes, Yes, No, No, No, N~
## $ time <dbl> 7, 8, 8, 10, 10, 10, 10, 11, 11, 12, 13, 14, ~
## $ DEATH_EVENT <fct> Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, ~
dplyr paketindeki glimpse fonksiyonunu kullanarak train veri kümemizin yapısını inceledik.
train$ejf_kat<-ifelse(train$ejection_fraction < 35, "Düsük", ifelse(train$ejection_fraction >= 35 & train$ejection_fraction <= 55,"Normal","Yüksek"))
train$srs_kat<-ifelse(train$serum_sodium < 135, "Düsük", ifelse(train$serum_sodium >= 135 & train$serum_sodium <= 145,"Normal","Yüksek"))
train veri kümesindeki ejection_fraction ve serum_sodium değişkenlerinden yeni gruplanmış kategorik değişkenler türettik.
train$ejf_kat<-factor(train$ejf_kat, levels=c("Düsük","Normal","Yüksek"))
train$srs_kat<-factor(train$srs_kat, levels=c("Düsük","Normal","Yüksek"))
Türetilen kategorik değişkenleri factor olarak tanımladık.
glimpse(train)
## Rows: 240
## Columns: 15
## $ age <dbl> 50, 65, 90, 60, 65, 80, 62, 45, 50, 49, 82, 8~
## $ anaemia <fct> Yes, Yes, Yes, Yes, No, Yes, No, Yes, Yes, Ye~
## $ creatinine_phosphokinase <dbl> 111, 160, 47, 315, 157, 123, 231, 981, 168, 8~
## $ diabetes <fct> No, Yes, No, Yes, No, No, No, No, No, No, No,~
## $ ejection_fraction <dbl> 20, 20, 40, 60, 65, 35, 25, 30, 38, 30, 50, 3~
## $ high_blood_pressure <fct> No, No, Yes, No, No, Yes, Yes, No, Yes, Yes, ~
## $ platelets <dbl> 210000, 327000, 204000, 454000, 263358, 38800~
## $ serum_creatinine <dbl> 1.90, 2.70, 2.10, 1.10, 1.50, 9.40, 0.90, 1.1~
## $ serum_sodium <dbl> 137, 116, 132, 131, 138, 133, 140, 137, 137, ~
## $ sex <fct> Male, Female, Male, Male, Female, Male, Male,~
## $ smoking <fct> No, No, Yes, Yes, No, Yes, Yes, No, No, No, N~
## $ time <dbl> 7, 8, 8, 10, 10, 10, 10, 11, 11, 12, 13, 14, ~
## $ DEATH_EVENT <fct> Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, ~
## $ ejf_kat <fct> Düsük, Düsük, Normal, Yüksek, Yüksek, Normal,~
## $ srs_kat <fct> Normal, Düsük, Düsük, Düsük, Normal, Düsük, N~
Yeni değişken türetme ve dönüşüm işlemlerinden sonra glimpse fonksiyonu ile train veri kümesinin yapısını yeniden inceledik.
4. Verilerin Açıklayıcı/Keşfedici Çözümlemesi
library(funModeling)
## Zorunlu paket yükleniyor: Hmisc
## Zorunlu paket yükleniyor: survival
##
## Attaching package: 'survival'
## The following object is masked from 'package:caret':
##
## cluster
## Zorunlu paket yükleniyor: Formula
##
## Attaching package: 'Hmisc'
## The following objects are masked from 'package:dplyr':
##
## src, summarize
## The following objects are masked from 'package:base':
##
## format.pval, units
## funModeling v.1.9.4 :)
## Examples and tutorials at livebook.datascienceheroes.com
## / Now in Spanish: librovivodecienciadedatos.ai
profiling_num(train)
## variable mean std_dev variation_coef p_01
## 1 age 60.87083 11.720417 0.19254570 40.000
## 2 creatinine_phosphokinase 543.43333 886.461465 1.63122394 47.000
## 3 ejection_fraction 37.99583 11.742174 0.30903846 18.170
## 4 platelets 266228.45200 99663.995430 0.37435516 65120.000
## 5 serum_creatinine 1.39275 1.061510 0.76216859 0.639
## 6 serum_sodium 136.77917 4.563497 0.03336398 122.170
## 7 time 130.23333 77.740609 0.59693326 8.780
## p_05 p_25 p_50 p_75 p_95 p_99 skewness
## 1 43.95 52.00 60.0 68.25 82.000 92.44 0.4859066
## 2 58.95 113.00 231.0 582.00 2070.050 4723.45 4.4200809
## 3 20.00 30.00 38.0 45.00 60.000 61.22 0.4874253
## 4 135850.00 212750.00 263179.0 304000.00 448150.000 539100.00 1.5251769
## 5 0.70 0.90 1.1 1.40 2.905 6.41 4.6269940
## 6 130.00 134.00 137.0 140.00 144.000 145.00 -1.1945801
## 7 14.00 72.75 112.5 205.00 250.000 275.27 0.1370103
## kurtosis iqr range_98 range_80
## 1 3.054171 16.25 [40, 92.4399999999999] [45, 75.2]
## 2 28.611651 469.00 [47, 4723.44999999998] [66, 1199.3]
## 3 2.662647 15.00 [18.17, 61.22] [25, 60]
## 4 9.387101 91250.00 [65120, 539100] [159500, 388100]
## 5 30.027941 0.50 [0.639, 6.40999999999999] [0.8, 2.1]
## 6 7.528240 6.00 [122.17, 145] [132, 142]
## 7 1.764446 132.25 [8.78, 275.27] [26.9, 241.3]
plot_num(train)
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
funmodeling paketindeki profiling_num ve plot_num fonksiyonlarını kullanarak train veri kümemizdeki nicel değişkenlere ait özet istatistikleri ve grafikleri elde ettik. Özet istatistikleri ve grafikleri incelediğimizde creatinine_phosphokinase, serum_creatinine ve platelets değişkenlerinin sağa çarpık olduğunu, serum_sodium değişkeninin sola çarpık olduğunu, age ve time değişkenlerinin ise homojen bir şekilde dağıldığını söyleyebiliriz.
freq(train)
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## anaemia frequency percentage cumulative_perc
## 1 No 132 55 55
## 2 Yes 108 45 100
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## diabetes frequency percentage cumulative_perc
## 1 No 131 54.58 54.58
## 2 Yes 109 45.42 100.00
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## high_blood_pressure frequency percentage cumulative_perc
## 1 No 153 63.75 63.75
## 2 Yes 87 36.25 100.00
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## sex frequency percentage cumulative_perc
## 1 Male 153 63.75 63.75
## 2 Female 87 36.25 100.00
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## smoking frequency percentage cumulative_perc
## 1 No 167 69.58 69.58
## 2 Yes 73 30.42 100.00
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## DEATH_EVENT frequency percentage cumulative_perc
## 1 No 163 67.92 67.92
## 2 Yes 77 32.08 100.00
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## ejf_kat frequency percentage cumulative_perc
## 1 Normal 134 55.83 55.83
## 2 Düsük 77 32.08 87.91
## 3 Yüksek 29 12.08 100.00
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
## srs_kat frequency percentage cumulative_perc
## 1 Normal 176 73.33 73.33
## 2 Düsük 62 25.83 99.16
## 3 Yüksek 2 0.83 100.00
## [1] "Variables processed: anaemia, diabetes, high_blood_pressure, sex, smoking, DEATH_EVENT, ejf_kat, srs_kat"
funmodeling paketi içerisinde yer alan freq fonksiyonunu kullanarak kategorik değişkenlerimizin frekans ve frekans oranlarını içeren grafikleri elde ettik.
library(psych)
##
## Attaching package: 'psych'
## The following object is masked from 'package:Hmisc':
##
## describe
## The following objects are masked from 'package:ggplot2':
##
## %+%, alpha
library(dplyr)
library(ggplot2)
df<-select(train,time,srs_kat)
describeBy(df, df$srs_kat)
##
## Descriptive statistics by group
## group: Düsük
## vars n mean sd median trimmed mad min max range skew kurtosis
## time 1 62 116.06 79.23 93.5 114.46 100.82 8 250 242 0.17 -1.54
## srs_kat* 2 62 1.00 0.00 1.0 1.00 0.00 1 1 0 NaN NaN
## se
## time 10.06
## srs_kat* 0.00
## ------------------------------------------------------------
## group: Normal
## vars n mean sd median trimmed mad min max range skew kurtosis
## time 1 176 135.27 76.75 116 134.53 98.59 7 285 278 0.14 -1.18
## srs_kat* 2 176 2.00 0.00 2 2.00 0.00 2 2 0 NaN NaN
## se
## time 5.79
## srs_kat* 0.00
## ------------------------------------------------------------
## group: Yüksek
## vars n mean sd median trimmed mad min max range skew kurtosis
## time 1 2 126 117.38 126 126 123.06 43 209 166 0 -2.75
## srs_kat* 2 2 3 0.00 3 3 0.00 3 3 0 NaN NaN
## se
## time 83
## srs_kat* 0
ggplot(train, aes(x=srs_kat,y=time, fill=srs_kat))+
geom_boxplot()+
stat_summary(fun = median, geom="line", group= 1, color= "black", size = 1.25)
Hasta takip süresinin (time değişkeni),kandaki serum sodyum seviyesi (srs_kat değişkeni) bazında özet istatistiklerini ve boxplot grafiğini elde ettik. Özet istatistikleri incelediğimizde kategorilerde düsük’ten yüksek’e doğru geçiş sağlandığında ortanca oranı arttıkça standart sapmanın da artış gösterdiği görülmekte, buna göre hastanın takip süresi ile kandaki serum sodyum seviyesi arasında doğrusal bir ilişkinin var olduğundan söz edebiliriz. Boxplot grafiklerini incelediğimizde kategorilerde düsük’ten yüksek’e doğru geçiş sağlandığında kutu genişliklerinin gittikçe küçüldüğü görülmekte, buna göre değişen varyanslılığın varlığından söz edebiliriz.
quantile(train$ejection_fraction)
## 0% 25% 50% 75% 100%
## 14 30 38 45 70
ejection_fraction_min <- as.vector(quantile(train$ejection_fraction,0.00))
ejection_fraction_q1 <- as.vector(quantile(train$ejection_fraction,0.25))
ejection_fraction_median <- as.vector(quantile(train$ejection_fraction,0.50))
ejection_fraction_q3 <- as.vector(quantile(train$ejection_fraction,0.75))
ejection_fraction_max <- as.vector(quantile(train$ejection_fraction,1.00))
quantile(train$serum_sodium)
## 0% 25% 50% 75% 100%
## 113 134 137 140 148
serum_sodium_min <- as.vector(quantile(train$serum_sodium,0.00))
serum_sodium_q1 <- as.vector(quantile(train$serum_sodium,0.25))
serum_sodium_median <- as.vector(quantile(train$serum_sodium,0.50))
serum_sodium_q3 <- as.vector(quantile(train$serum_sodium,0.75))
serum_sodium_max <- as.vector(quantile(train$serum_sodium,1.00))
Train veri kümemimize ait ejection_fraction ve serum_sodium nicel değişkenlerinin 5 nokta ölçülerini (mimimum, Q1, medyan, Q3, maksimum) hesapladık ve bu değerleri değişkenlere atadık. Bu değişkenlerden yararlanarak, ejection_fraction ve serum_sodium değişkenlerimiz için DAG ve Genişlik ölçülerini hesaplayacağız.
ejection_fraction_DAG <- ejection_fraction_q3 - ejection_fraction_q1
ejection_fraction_DAG
## [1] 15
ejection_fraction_Genislik <- ejection_fraction_max - ejection_fraction_min
ejection_fraction_Genislik
## [1] 56
serum_sodium_DAG <- serum_sodium_q3 - serum_sodium_q1
serum_sodium_DAG
## [1] 6
serum_sodium_Genislik <- serum_sodium_max - serum_sodium_min
serum_sodium_Genislik
## [1] 35
ejection_fraction ve serum_sodium değişkenlerimize ait DAG ve Genişlik ölçülerini elde ettik ve bunları değişkenlere atadık. (ejection_fraction_DAG - ejection_fraction_Genislik - serum_sodium_DAG - serum_sodium_Genislik)
stdev<-sd(train$age)
mean<-mean(train$age)
Degisim_kats_age<-(stdev/mean)*100
Degisim_kats_age
## [1] 19.25457
Train veri kümemizdeki age değişkeni için değişim katsayısı hesapladık. Age değişkeni için yaklaşık %20’lik bir değişim katsayısı elde ettik. Bu sonuca göre age değişkeninin yaklaşık simetrik olduğunu söyleyebiliriz.
sd_dk <- function(x) {c(std<-sd(x), dk<-(sd(x)/mean(x))*100)}
tapply(train$time, train$sex,sd_dk)
## $Female
## [1] 79.29039 59.35522
##
## $Male
## [1] 77.04269 60.03633
sex değişkenine göre time değişkeninin standart sapmasını ve değişim katsayısını hesapladık. Elde ettiğimiz değişim katsayısı değerlerini incelediğimizde, kadınların time değişkenindeki yayılımının, erkeklere göre daha fazla olduğunu söyleyebiliriz.
sort <- train[order(train$age),]
medianf<-median(sort$age)
sort$fmed<-abs(sort$age-medianf)
sort2 <- sort[order(sort$fmed),]
mad<-median(sort2$fmed)
mad
## [1] 8
Train veri kümemizdeki age değişkeni için ortalama/ortanca mutlak sapma (mad) değerini hesapladık. Elde ettiğimiz mad değeri küçük olduğu için age değişkeni içerisindeki değerlerin ortalama çevresinde birbirine yakın kümelendiklerini söyleyebiliriz.
sol_kuyruk <- function(x) {
c(quantile(x,probs=1/2) ,
quantile(x,probs=1/4),
quantile(x,probs=1/8 ),
quantile(x,probs=1/16),
quantile(x,probs=1/32),
quantile(x,probs=1/64)
)
}
sag_kuyruk <- function(x) {
c(quantile(x,probs=1/2) ,
quantile(x,probs=3/4),
quantile(x,probs=7/8),
quantile(x,probs=15/16),
quantile(x,probs=31/32),
quantile(x,probs=63/64)
)
}
sol kuyruk ve sağ kuyruk değişkenleri oluşturuldu.
y<-tapply(train$time, train$sex, sol_kuyruk)
mrg_cins<-as.data.frame(cbind(y[[1]],y[[2]]))
colnames(mrg_cins)<-c("Female","Male")
mrg_cins$Fark<-abs(mrg_cins$Female-mrg_cins$Male)
mrg_cins
## Female Male Fark
## 50% 115.0000 112.00 3.0000
## 25% 74.0000 72.00 2.0000
## 12.5% 30.0000 30.00 0.0000
## 6.25% 21.1250 17.00 4.1250
## 3.125% 14.0625 10.75 3.3125
## 1.5625% 10.6875 10.00 0.6875
Cinsiyete göre sol kuyruk incelemesi gerçekleştirildi.
x_a<-sol_kuyruk(train$ejection_fraction)
x_u<-sag_kuyruk(train$ejection_fraction)
x_mrg<-as.data.frame(cbind(x_a,x_u))
rownames(x_mrg)<-c("1/2","1/4","1/8","1/16","1/32","1/64")
colnames(x_mrg)<-c("Alt_Kuyruk","Ust_Kuyruk")
x_mrg$orta_nokta<-(x_mrg$Alt_Kuyruk+x_mrg$Ust_Kuyruk)/2
x_mrg
## Alt_Kuyruk Ust_Kuyruk orta_nokta
## 1/2 38 38 38.0
## 1/4 30 45 37.5
## 1/8 25 55 40.0
## 1/16 20 60 40.0
## 1/32 20 60 40.0
## 1/64 20 60 40.0
hist(train$ejection_fraction)
x_a<-sol_kuyruk(train$serum_sodium)
x_u<-sag_kuyruk(train$serum_sodium)
x_mrg<-as.data.frame(cbind(x_a,x_u))
rownames(x_mrg)<-c("1/2","1/4","1/8","1/16","1/32","1/64")
colnames(x_mrg)<-c("Alt_Kuyruk","Ust_Kuyruk")
x_mrg$orta_nokta<-(x_mrg$Alt_Kuyruk+x_mrg$Ust_Kuyruk)/2
x_mrg
## Alt_Kuyruk Ust_Kuyruk orta_nokta
## 1/2 137.0000 137.0000 137.0000
## 1/4 134.0000 140.0000 137.0000
## 1/8 132.0000 141.0000 136.5000
## 1/16 130.0000 143.0625 136.5312
## 1/32 127.0000 145.0000 136.0000
## 1/64 124.7344 145.0000 134.8672
hist(train$serum_sodium)
Train veri kümemizdeki ejection_fraction ve serum_sodium değişkenleri için kuyruk uzunlukları ve histogram grafikleri elde edilmiştir. Elde edilen sonuçlar incelendiğinde ejection_fraction değişkeninin simetrik’e yakın, serum_sodium değişkeninin ise sola çarpık dağıldığını söyleyebiliriz.
p<-0.1
mean(train$serum_sodium, trim = p)
## [1] 137.0052
n<-nrow(train$serum_sodium)
ks<- n-(as.integer(2*p*n))
ks
## integer(0)
geometric.mean(train$serum_sodium)
## [1] 136.701
Train veri kümemizdeki serum_sodium değişkenine ait kesilmiş ortalama, kalan gözlem sayısı ve geometrik ortalama hesaplandı.
table(train$sex)
##
## Female Male
## 87 153
freq <- as.data.frame(table(train$sex))
names(freq)[1] <- 'sex'
freq
## sex Freq
## 1 Female 87
## 2 Male 153
gini <- function(a,b) {
a1 <- (a/(a+b))**2
b1 <- (b/(a+b))**2
x<-1-(a1 + b1)
return(x)
}
gn<-gini(freq[1,2],freq[2,2])
k<-2
gn/((k-1)/k)
## [1] 0.924375
table(train$smoking)
##
## No Yes
## 167 73
freq <- as.data.frame(table(train$smoking))
names(freq)[1] <- 'smoking'
freq
## smoking Freq
## 1 No 167
## 2 Yes 73
gini <- function(a,b) {
a1 <- (a/(a+b))**2
b1 <- (b/(a+b))**2
x<-1-(a1 + b1)
return(x)
}
gn<-gini(freq[1,2],freq[2,2])
k<-2
gn/((k-1)/k)
## [1] 0.8465972
table(train$DEATH_EVENT)
##
## No Yes
## 163 77
freq <- as.data.frame(table(train$DEATH_EVENT))
names(freq)[1] <- 'death_event'
freq
## death_event Freq
## 1 No 163
## 2 Yes 77
gini <- function(a,b) {
a1 <- (a/(a+b))**2
b1 <- (b/(a+b))**2
x<-1-(a1 + b1)
return(x)
}
gn<-gini(freq[1,2],freq[2,2])
k<-2
gn/((k-1)/k)
## [1] 0.8715972
Train veri kümemizdeki sex, smoking ve DEATH_EVENT değişkenleri için gini indeksleri hesaplandı. sex, smoking ve DEATH_EVENT değişkenlerine ait gini indeksleri 1’e yakın değer aldılar. Bu sonuçları göz önünde bulundurduğumuzda sex, smoking ve DEATH_EVENT değişkenlerinin hetorejen bir şekilde dağıldıklarını söyleyebiliriz.
train$hastalik <- ifelse(train$high_blood_pressure == "Yes", "Hasta","HDeğil")
train$hastalik <- as.factor(train$hastalik)
Train veri kümemizdeki high_blood_pressure değişkeninden yararlanarak, hastalik isimli yeni bir değişken oluşturduk. hastalik değişkenini factor formatına çevirdik.
glimpse(train)
## Rows: 240
## Columns: 16
## $ age <dbl> 50, 65, 90, 60, 65, 80, 62, 45, 50, 49, 82, 8~
## $ anaemia <fct> Yes, Yes, Yes, Yes, No, Yes, No, Yes, Yes, Ye~
## $ creatinine_phosphokinase <dbl> 111, 160, 47, 315, 157, 123, 231, 981, 168, 8~
## $ diabetes <fct> No, Yes, No, Yes, No, No, No, No, No, No, No,~
## $ ejection_fraction <dbl> 20, 20, 40, 60, 65, 35, 25, 30, 38, 30, 50, 3~
## $ high_blood_pressure <fct> No, No, Yes, No, No, Yes, Yes, No, Yes, Yes, ~
## $ platelets <dbl> 210000, 327000, 204000, 454000, 263358, 38800~
## $ serum_creatinine <dbl> 1.90, 2.70, 2.10, 1.10, 1.50, 9.40, 0.90, 1.1~
## $ serum_sodium <dbl> 137, 116, 132, 131, 138, 133, 140, 137, 137, ~
## $ sex <fct> Male, Female, Male, Male, Female, Male, Male,~
## $ smoking <fct> No, No, Yes, Yes, No, Yes, Yes, No, No, No, N~
## $ time <dbl> 7, 8, 8, 10, 10, 10, 10, 11, 11, 12, 13, 14, ~
## $ DEATH_EVENT <fct> Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, Yes, ~
## $ ejf_kat <fct> Düsük, Düsük, Normal, Yüksek, Yüksek, Normal,~
## $ srs_kat <fct> Normal, Düsük, Düsük, Düsük, Normal, Düsük, N~
## $ hastalik <fct> HDeğil, HDeğil, Hasta, HDeğil, HDeğil, Hasta,~
Değişken oluşturma ve dönüşüm işlemlerinden sonra train veri kümesinin yapısını inceledik.
dt<-table(train$hastalik,train$DEATH_EVENT)
dt
##
## No Yes
## Hasta 55 32
## HDeğil 108 45
Train veri kümemizdeki hastalik ve DEATH_EVENT değişkenlerini kullanarak, hipertansiyon hastalığına sahip olan ve olmayan kişilere ait ölüm sayılarını içeren dt isimli tabloyu oluşturduk.
round(100*prop.table(dt,2), 2)
##
## No Yes
## Hasta 33.74 41.56
## HDeğil 66.26 58.44
hipertansiyon hastalığına sahip olan ve olmayan kişilere ait ölüm sayılarını içeren dt isimli tabloyu kullanarak bu sayıların yüzdesel olarak ifade edildiği tabloyu oluşturduk.
library(DescTools)
##
## Attaching package: 'DescTools'
## The following objects are masked from 'package:psych':
##
## AUC, ICC, SD
## The following objects are masked from 'package:Hmisc':
##
## %nin%, Label, Mean, Quantile
## The following objects are masked from 'package:caret':
##
## MAE, RMSE
Assocs(dt)[1:3,1]
## Phi Coeff. Contingency Coeff. Cramer V
## 0.07589698 0.07567932 0.07589698
gplots paketindeki, balloonplot fonksiyonu ile, dt tablosunu kaynak alarak hipertansiyon rahatsızlığı ve ölüm durumu ile ilgili bir çapraz tablo oluşturduk. Çapraz tabloyu incelediğimizde hipertansiyon rahatsızlığına sahip olmayanlarda ölü sayısının, hipertansiyon rahatsızlığı olanlara göre daha fazla olduğu görülmektedir. Buna göre kabaca hipertansiyon rahatsızlığının ölüme sebep olma olasılığı düşüktür diyebiliriz.
OR <- OddsRatio(dt, conf.level=0.95)
OR
## odds ratio lwr.ci upr.ci
## 0.7161458 0.4100860 1.2506275
OddsRatio fonksiyonunu kullanarak dt tablomuza ait odds oranını hesapladık. Odds oranını 0.71 olarak bulduk. Buna göre hipertansiyon rahatsızlığına sahip olan hastaların, hipertansiyon rahatsızlığına sahip olmayan hastalara göre ölme olasılığı yaklaşık 0.7 kat daha fazladır diyebiliriz.
dt2<-xtabs(~ hastalik+sex+smoking, data=train)
dt22<-as.data.frame(ftable(dt2))
library(ggpubr)
ggballoonplot(
dt22, x = "smoking", y = "sex",
size = "Freq", fill = "Freq",
facet.by = "hastalik",
ggtheme = theme_bw())
Yukarıdaki çapraz tablo ile hipertansiyon rahatsızlığının cinsiyete ve sigara kullanımına göre nasıl bir değişkenlik gösterdiğini elde ettik. Elde edilen sonuçları incelediğimizde erkeklerde sigara kullanımının hipertansiyon rahatsızlığına sahip olup olmamasında pek bir farklılık yaratmadığını, kadınlarda ise sigara kullanmayanların kullananlara göre hipertansiyon rahatsızlığına yakalanmalarının daha fazla olduğunu söyleyebiliriz.
dt_c<-table(train$srs_kat,train$hastalik)
dtc_exp <- chisq.test(dt_c)$expected
## Warning in chisq.test(dt_c): Chi-squared approximation may be incorrect
rowcs <- function(i, obs, exp) {
sum(((obs[i,] - exp[i,])^2)/exp[i,])
}
chi_dtc<-as.matrix(lapply(seq_len(nrow(dt_c)), rowcs, obs = dt_c, exp = dtc_exp))
rownames(chi_dtc)<-rownames(dt_c)
chi_dtc
## [,1]
## Düsük 0.01923706
## Normal 0.01573545
## Yüksek 0.1636241
kandaki serum sodyum oranının, hipertansiyon rahatsızlığını nasıl etkilediğine ilişkin satır ki-karelerini elde ettik. kandaki düsük ve normal serum sodyum oranları için satır ki-karelerini 0.01, yüksek için ise 0.16 olarak bulduk. Bu sonuçlara göre kandaki yüksek serum sodyum seviyesinin hipertansiyon rahatsızlığını etkilediğini ve birlikteliği bozduğunu söyleyebiliriz.
library(inspectdf)
library(dplyr)
train %>% inspect_types()
## # A tibble: 2 x 4
## type cnt pcnt col_name
## <chr> <int> <dbl> <named list>
## 1 factor 9 56.2 <chr [9]>
## 2 numeric 7 43.8 <chr [7]>
Yukarıda yapmış olduğumuz işlemlerden sonra train veri kümemizin yapısını yeniden incelemeye aldık. Yaptığımız incelemelere göre veri kümemizin 9 factor ve 7 numeric değişkenden oluştuğunu ve bunların veri setinin yüzde kaçını kapsadığı sonuçlarına ulaştık.
tra_cat<-train %>% inspect_cat()
tra_cat %>% show_plot()
Train veri kümemizdeki kategorik değişkenlerin düzeyleri bazında dağılımını veren grafiği oluşturduk ve incelemelerimizi gerçekleştirdik.
library(ggplot2)
library(plotly)
##
## Attaching package: 'plotly'
## The following object is masked from 'package:Hmisc':
##
## subplot
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
library(ggpubr)
ggplot2, plotly ve ggpubr paketlerini çağırdık.
cross<-as.data.frame(prop.table(table(train$smoking)))
colnames(cross)[1] <- "smoking"
plot_ly(cross, labels = ~smoking, values = ~Freq, type = 'pie')%>% layout(title ='Sigara Kullanımına Ait Dağılım')
Plotly paketindeki plot_ly fonksiyonundan yararlanarak sigara kullanımına ait dağılımı gösteren pie chart grafiğini elde ettik. Grafiği incelediğimizde; hastalarda sigara kullanmayanların (oranı %69.6), sigara kullananlara (oranı %30.4) göre daha fazla olduğu görülmüştür.
ggplot(train,aes(srs_kat, fill=sex))+
geom_bar(position=position_dodge())+
ggtitle("Serum Sodyum Seviyesi Kategorilerindeki Cinsiyet Dağılımı")+
geom_bar() +
geom_text(aes(label=..count..),stat="count",position=position_stack(0.5))+
xlab("Serum Sodyum Seviyesi Kategorileri")+
ylab("Sıklıklar")+
scale_fill_discrete(name = "Cinsiyet")+
theme(axis.title.x = element_text(color="black", face="bold", size=12),
axis.title.y = element_text(color="black", face="bold",size=12),
plot.title = element_text(hjust = 0.5,color="black", face="bold", size=14),
legend.title = element_text(colour="black",face="bold",size=12))
ggplot paketindeki fonksiyonları kullanarak; kandaki serum sodyum seviyesi kategorilerinin (srs_kat değişkeninin) cinsiyetlere (sex değişkenine) göre dağılım bilgisini veren bar grafiğini çizdirdik. Grafikleri incelediğimizde hastaların serum sodyum seviyesi normal olanların train veri kümesinde daha çok yer kapladığı anlaşılmıştır. Train veri kümesinde serum sodyum seviyesi düşük olan 62 kişi (41 erkek, 21 kadın), normal olan 176 kişi (111 erkek, 65 kadın) ve yüksek olan 2 kişi (1 erkek, 1 kadın) olduğu görülmüştür.
ggplot(train,aes(ejf_kat, fill=sex))+
geom_bar(position=position_dodge())+
ggtitle("Ejeksiyon Fraksiyonu Seviyesi Kategorilerindeki Cinsiyet Dağılımı")+
geom_bar() +
geom_text(aes(label=..count..),stat="count",position=position_stack(0.5))+
xlab("Ejeksiyon Fraksiyonu Seviyesi Kategorileri")+
ylab("Sıklıklar")+
scale_fill_discrete(name = "Cinsiyet")+
theme(axis.title.x = element_text(color="black", face="bold", size=12),
axis.title.y = element_text(color="black", face="bold",size=12),
plot.title = element_text(hjust = 0.5,color="black", face="bold", size=14),
legend.title = element_text(colour="black",face="bold",size=12))
ggplot paketindeki fonksiyonları kullanarak; ejeksiyon fraksiyonu seviyesi kategorilerinin (ejf_kat değişkeninin) cinsiyetlere (sex değişkenine) göre dağılım bilgisini veren bar grafiğini çizdirdik. Grafikleri incelediğimizde hastaların ejeksiyon fraksiyonu seviyesi normal olanların train veri kümesinde daha çok yer kapladığı anlaşılmıştır. Train veri kümesinde ejeksiyon fraksiyonu seviyesi düşük olan 77 kişi (53 erkek, 24 kadın), normal olan 134 kişi (86 erkek, 48 kadın) ve yüksek olan 29 kişi (14 erkek, 15 kadın) olduğu görülmüştür.
k<-ceiling((log(2*nrow(train)))+1)
genislik_age<-max(train$age)-min(train$age)
binw_1<-genislik_age/k
ggplot(train,aes(age))+
geom_histogram(binwidth=binw_1,
fill="olivedrab4",colour="black", alpha=0.6)+
ggtitle("Hasta Yaşlarına Ait Dağılım")
ggplot paketindeki fonksiyonları kullanarak, hasta yaşlarının (age değişkeninin) dağılım bilgisini veren histogram grafiğini çizdirdik. Grafiği incelediğimizde çok az sağa çarpıklıktan bahsedebiliriz.
ggplot(train,aes(age,fill=sex))+
geom_histogram(binwidth=binw_1)+
facet_grid(sex~.)+
ggtitle("Cinsiyetlere Göre Hasta Yaşlarına Ait Dağılım")
Hasta yaşlarına ait dağılım grafiğimizin, cimsiyetlere göre kırılımını gösteren histogram grafiklerini çizdirdik. Grafikleri imcelediğimizde, kadın ve erkek hastaların dağılım grafiklerinin hafif sağa çarpık olduğunu ifade edebiliriz.
ggqqplot(train$ejection_fraction)
l<-ceiling((log(2*nrow(train)))+1)
genislik_ejection_fraction<-max(train$ejection_fraction)-min(train$ejection_fraction)
binw_2<-genislik_ejection_fraction/l
ggplot(train,aes(ejection_fraction))+
geom_histogram(binwidth=binw_2,
fill="steelblue",colour="black", alpha=0.6)+
ggtitle("Ejeksiyon Fraksiyon Seviyesine Ait Dağılım")
Ejeksiyon fraksiyon seviyesine ait Q-Q plot ve histogram grafiklerini çizdirdik. Ejeksiyon fraksiyon seviyesi Q-Q plot grafiğini incelediğimizde merdiven biçiminde bir grafik olduğu için çarpıklık olduğu kesindir, aykırı ve uç değerler vardır.Uygun dönüşüm yapılıp tekrardan incelenmelidir.
ggplot(train, aes(x = ejf_kat, y = age, fill = DEATH_EVENT)) +
geom_boxplot(position = position_dodge(width = 0.9)) +
stat_summary(fun = median,geom = 'line',
aes(group = DEATH_EVENT, colour = DEATH_EVENT),size=1,
position = position_dodge(width = 0.9))
Grafiği incelediğimizde; ejeksiyon fraksiyon seviyesi (kalbin her kasılmasında ortaya çıkan kan yüzdesi) düşük olup hayatını kaybetmiş olan hastaların kutu genişliğine bakıldığında, geniş bir yaş dağılımına sahip oldukları görülmektedir. Buna göre ölümlerin yaşın genç olması ya da yaşlı olmasına değilde ejeksiyon fraksiyon seviyesine bağlı olarak ortaya çıkan kalp yetmezliğine bağlı olduğunu söyleyebiliriz.
library(tidyverse)
## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --
## v tibble 3.1.6 v purrr 0.3.4
## v tidyr 1.2.0 v stringr 1.4.0
## v readr 2.1.2 v forcats 0.5.1
## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x psych::%+%() masks ggplot2::%+%()
## x psych::alpha() masks ggplot2::alpha()
## x plotly::filter() masks dplyr::filter(), mice::filter(), stats::filter()
## x dplyr::lag() masks stats::lag()
## x purrr::lift() masks caret::lift()
## x Hmisc::src() masks dplyr::src()
## x Hmisc::summarize() masks dplyr::summarize()
tidyverse paketini çağırdık.
ggplot(train, aes(serum_creatinine, ejection_fraction))+
geom_point(size=2,shape=21,stroke=1,color="deepskyblue3", fill="deepskyblue3")+
geom_smooth(method = "lm", col="darkblue",se = FALSE)
## `geom_smooth()` using formula 'y ~ x'
İkili değişken dağılımı incelendiğinde yoğunluğun serum kreatinin seviyesinin düşük olduğu aralıkta yoğunlaştığı söylenebilir. Değişen varyanslılıktan söz edilemez.
library(plotly)
d_plot <- ggplot(train, aes(serum_creatinine, ejection_fraction, fill=DEATH_EVENT, shape=DEATH_EVENT)) +
geom_point(position = position_jitter(width= 0.2, height = 0), size = 2)
ggplotly(d_plot)
ejeksiyon fraksiyon seviyesine (kalbin her kasılmasında ortaya çıkan kan yüzdesi) bağlı serum kreatinin seviyesi ve ölüm sayısının dağılım grafiği incelendiğinde serum kreatinin seviyesi değeri düşükl aralıkta olan kişilerde mavi renge sahip olan üçgenlerin daha fazla olduğu görülmektedir. Buna göre serum kreatinin seviyesi değeri düşük olan kişilerde ölüm daha fazladır diyebiliriz.
library(ggExtra)
gr<-ggplot(train,aes(x=serum_creatinine,y=ejection_fraction))+
geom_point()+
geom_text(size=3,label=rownames(train),nudge_x=0.25,
nudge_y=0.25, check_overlap=T)+
geom_smooth(method=lm,col="brown1", se=FALSE)
ggMarginal(gr,type="histogram",fill="darksalmon")
## `geom_smooth()` using formula 'y ~ x'
## `geom_smooth()` using formula 'y ~ x'
ejeksiyon fraksiyon seviyesi değişkeninin (kalbin her kasılmasında ortaya çıkan kan yüzdesi) serum kreatinin seviyesi değişkeni ile dağılımı incelendiğinde iki değişken arasında doğrusal bir ilişki olmadığı söylenebilir. İleride yapılacak incelemelerde değişkenlere gereken dönüşümler yapılarak ve aykırı değerler çıkartılarak bu durum giderilebilir.
cor_train<-train[,c(8,7,5)]
panel.cor <- function(x,y,digits=2,prefix="",cex.cor)
{
usr <- par("usr"); on.exit(par(usr))
par(usr=c(0,1,0,1))
r=(cor(x,y))
txt <- format(c(r,0.123456789),digits=digits)[1]
txt <- paste(prefix, txt, sep="")
if(missing(cex.cor)) cex <- 0.8/strwidth(txt)
text(0.5, 0.5, txt, cex=cex*abs(r))
}
panel.hist <- function(x, ...)
{
usr <- par("usr"); on.exit(par(usr))
par(usr = c(usr[1:2], 0, 1.5) )
h <- hist(x, plot = FALSE)
breaks <- h$breaks; nB <- length(breaks)
y <- h$counts; y <- y/max(y)
rect(breaks[-nB], 0, breaks[-1], y, col="cyan", ...)
}
pairs(cor_train, lower.panel=panel.smooth, upper.panel=panel.cor)
pairs(cor_train, diag.panel=panel.hist, lower.panel=panel.smooth, upper.panel=panel.cor)
pairs(cor_train, diag.panel=panel.hist,lower.panel=function(x,y) panel.smooth(x, y, pch=".", lwd=2), upper.panel=panel.cor)
serum kreatinin seviyesi, platelets (kandaki trambositler) ve ejeksiyon fraksiyon seviyesi(kalbin her kasılmasında ortaya çıkan kan yüzdesi) değişkenleri için saçılım grafikleri çizdirildi. Saçılım grafikleri incelendiğinde değişkenler arasında anlamlı bir ilişkinin varlığından söz edilemez. Gerekli dönüşümler yapılarak bu sorun giderilebilir.
library(rcompanion)
##
## Attaching package: 'rcompanion'
## The following object is masked from 'package:psych':
##
## phi
rcompanion paketini markdown içerisinde aktif hale getirdik.
serum_creatinine_tukey<-transformTukey(train$serum_creatinine,plotit=FALSE)
##
## lambda W Shapiro.p.value
## 360 -1.025 0.9846 0.01051
##
## if (lambda > 0){TRANS = x ^ lambda}
## if (lambda == 0){TRANS = log(x)}
## if (lambda < 0){TRANS = -1 * x ^ lambda}
Serum kreatinin değişkeninin lamda değeri -1.15 olarak bulunmuştur. Bu değer sıfırdan küçük olduğu için ters kök değişimi uygulanarak var olan sağa çarpıklığı simetrik hale getirmeye çalışalım.
train$serum_creatinine_terskok <- (train$serum_creatinine)^(-0.5)
hist(train$serum_creatinine, col = "palevioletred3")
hist(train$serum_creatinine_terskok, col = "palevioletred3")
platelets değişkeninin (kandaki trambositler) lamda değeri 0.45 olarak hesaplanmıştır. Bu değeri en yakın yuvarkayacağımız değer 0.5’tir. Bu yüzden kök dönüşümü uygulayarak hafif sağa çarpıklığı gidermeliyiz.
train$platelets_sqrt<-sqrt(train$platelets)
hist(train$platelets, col = "aquamarine3")
hist(train$platelets_sqrt, col = "aquamarine3")
Ejeksiyon fraksiyon lamda değeri 0.225 olarak hesaplanmıştır. Bu değeri sıfıra eşit kabul ederek logaritma (log) dönüşümü uygulamalıyız .
train$ejection_fraction_log<-log10(train$ejection_fraction)
hist(train$ejection_fraction, col = "turquoise4")
hist(train$ejection_fraction_log, col = "turquoise4")
serum kreatinin ve ejeksiyon fraksiyon değişkenlerine dönüşüm uygulandıktan sonra saçılım grafiklerini yeniden çizdirdik. Grafiği incelediğimizde dönüşüm işlemine rağmen serum kreatinin ile ejeksiyon fraksiyon arasında hala doğrusal bir ilişki olmadığı söylenebilir. Çok fazla uç değer bulunmaktadır.
cor_train<-train[,c(17,18,19)]
panel.cor <- function(x,y,digits=2,prefix="",cex.cor)
{
usr <- par("usr"); on.exit(par(usr))
par(usr=c(0,1,0,1))
r=(cor(x,y))
txt <- format(c(r,0.123456789),digits=digits)[1]
txt <- paste(prefix, txt, sep="")
if(missing(cex.cor)) cex <- 0.8/strwidth(txt)
text(0.5, 0.5, txt, cex=cex*abs(r))
}
panel.hist <- function(x, ...)
{
usr <- par("usr"); on.exit(par(usr))
par(usr = c(usr[1:2], 0, 1.5) )
h <- hist(x, plot = FALSE)
breaks <- h$breaks; nB <- length(breaks)
y <- h$counts; y <- y/max(y)
rect(breaks[-nB], 0, breaks[-1], y, col="cyan", ...)
}
pairs(cor_train, lower.panel=panel.smooth, upper.panel=panel.cor)
pairs(cor_train, diag.panel=panel.hist, lower.panel=panel.smooth, upper.panel=panel.cor)
pairs(cor_train, diag.panel=panel.hist,lower.panel=function(x,y) panel.smooth(x, y, pch=".", lwd=2), upper.panel=panel.cor)
Gerekli dönüşümler yapıldıktan sonra saçılım grafiklerini karşılaştırdığımızda dönüşüm yapılmamış saçılım grafiği ilişki değerleri dönüşüm yapılan grafiğe göre daha düşüktür. Dönüşüm yapılan saçılım grafiği ilişi katsayıları yüksektir fakat değişkenler araasında doğrusal bir ilişki olduğu söylenemez. Modelleme adımında değişkenlere gerekli dönüşümler uygulanıp tekrardan denenebilir.
table3 <- xtabs(~sex+ejf_kat+smoking, data = train)
ftable(table3)
## smoking No Yes
## sex ejf_kat
## Female Düsük 23 1
## Normal 47 1
## Yüksek 14 1
## Male Düsük 29 24
## Normal 46 40
## Yüksek 8 6
Cinsiyetlerin ejeksiyon fraksiyon (kalbin her kasılmasında ortaya çıkan kan yüzdesi) kategorilerinde sigara kullanımını gösteren tabloyu oluşturduk.
library(ggplot2)
library(ggmosaic)
ggplot2 ve ggmosaic paketlerini markdown içerisinde aktif hale getirdik.
ggplot(train) +
geom_mosaic(aes(x = product(sex, smoking), fill=sex), na.rm=TRUE) + labs(x = "Sigara Kullanımı ", title='Kalp Kasılmasında Ortaya Çıkan Kan Yüzdesi Kategorisi, Cinsiyet ve Sigara ') +
facet_grid(ejf_kat~.)
## Warning: `unite_()` was deprecated in tidyr 1.2.0.
## Please use `unite()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was generated.
Tabloyu incelediğimizde ejeksiyon fraksiyon kategorisi yüksek olan erkeklerin sigara kullanma frekansı da yüksektir. Kadnlarda bu durum erkeklere göre daha düşüktür.
library(aplpack)
## Registered S3 method overwritten by 'aplpack':
## method from
## plot.bagplot DescTools
##
## Attaching package: 'aplpack'
## The following object is masked from 'package:DescTools':
##
## plot.bagplot
library(dplyr)
aplpack ve dplyr paketlerini markdown içerisinde aktif hale getirdik.
new_data<-train%>%
group_by(ejf_kat) %>%
dplyr::summarize(mean_ejf = mean(ejection_fraction),mean_plt = mean(platelets),mean_yas = mean(age))
faces(new_data[,-1], labels=as.character(new_data$ejf_kat))
## effect of variables:
## modified item Var
## "height of face " "mean_ejf"
## "width of face " "mean_plt"
## "structure of face" "mean_yas"
## "height of mouth " "mean_ejf"
## "width of mouth " "mean_plt"
## "smiling " "mean_yas"
## "height of eyes " "mean_ejf"
## "width of eyes " "mean_plt"
## "height of hair " "mean_yas"
## "width of hair " "mean_ejf"
## "style of hair " "mean_plt"
## "height of nose " "mean_yas"
## "width of nose " "mean_ejf"
## "width of ear " "mean_plt"
## "height of ear " "mean_yas"
train veri kümesindeki ejeksiyon fraksiyonu değişkeni için ejf_kat, platelets ve age değişkenlerinden yararlanarak Chernoff yüzleri oluşturuldu.
Chernoff yüzlerini incelediğimizde ejeksiyon fraksiyon seviyesinin düşük kategorisinde ağız, göz, burun ve kulağın şekil açısından diğerlerine kıyasla daha dar ve küçük bir yapıya sahip olduğu görülüyor.Yani değişken değerlerinin daha düşük olduğunu söyleyebiliriz. Ejeksiyon fraksiyon seviyesinin normal kategorisine ait chernoff yüzünü incelersek; ağız kısmında smiling yoktur. Yani yaş ortalamasının en düşük olduğu kategori olduğunu söyleyebiliriz. Yüzdeki organların normal düzeylerde şekillendiği söylenebilir. Yani değişken değerleri normal düzeyde dağılmaktadır. Ejeksiyon fraksiyon seviyesinin yüksek kategorisinde ki chernoff yüzünün daha güleç ve yüzdeki organların daha büyük düzeylerde şekillendiği söylenebilir. Yani değişken değerlerinin daha büyük olduğunu söyleyebiliriz. Saçlar ise yukarıya doğru bakıyor. Bu durum bize yaş ortalaması en büyük olan kategorinin yüksek kategorisi olduğunu söylemektedir.
